home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / debug / util.sml < prev   
Encoding:
Text File  |  1993-01-27  |  3.5 KB  |  127 lines
  1. (* DebugUtil.sml 
  2.  
  3.    Utility functions for debugger code.
  4.  
  5. *)
  6.  
  7. signature DEBUG_UTIL =
  8. sig
  9.   (* Basic list and array operators. *)
  10.   val smash: ('a -> 'b list) -> 'a list -> 'b list
  11.   val pairlist: 'a list -> 'b list -> ('a * 'b) list
  12.   val unpairlist: ('a * 'b) list -> (('a list) * ('b list))
  13.   val tln: ('a list*int) -> 'a list  (* last n elements of list *)
  14.   val filter: ('a ->bool) -> 'a list -> 'a list
  15.   exception Index
  16.   val index: ('a -> bool) -> 'a list -> int
  17.  
  18.   (* A very large signed integer. We implicitly assume that all real time
  19.    values are less than this, which is rather dangerous... *)
  20.   val infinity: int
  21.  
  22.   (* Diagnostic printing. *)
  23.   val debugdebug: bool ref  (* True if diagnostic reports are to be printed. *)
  24.   val dbgprint: string -> unit  (* Print diagnostic report. *)
  25.   val sizereport: (string -> unit) ref  (* Perform and print size report. *)
  26.  
  27.   val debugStatEnv: Modules.env ref  
  28.    (* Environment to use for printing types when we've nothing better to
  29.       use (e.g., in diagnostic reports). This should *not* be a special
  30.       debugger environment or diagnostic printing in the implementation of
  31.       special envs will loop! *)
  32.  
  33.   (* General purpose error-handling. *)
  34.   exception DebugError
  35.   val debugPanic: string -> 'a
  36.   val assert: (bool * string) -> unit
  37.  
  38.   (* Abstract syntax operators. *)
  39.   val patvars: (Variables.var -> 'a) -> Absyn.pat -> 'a list
  40.   val vblextract: (Variables.var -> 'a) ->    Absyn.vb list -> 'a list
  41.  
  42.   (* Encourage a minor garbage collection. *)
  43.   val forcegc: unit -> unit
  44.  
  45.   (* Handy continuation stuff. *)
  46.   val makeCont:string -> '1a cont
  47.  
  48.   (* Misc. functions *)
  49.   val isFn: Types.ty -> bool
  50. end
  51.  
  52. structure DebugUtil: DEBUG_UTIL =
  53. struct
  54.   open Array List Access Variables Absyn ErrorMsg
  55.   infix 9 sub
  56.   structure U = System.Unsafe
  57.  
  58.   fun smash f l = fold (fn (a,c) => f a @ c) l []
  59.   fun pairlist (a::ar) (b::br) = (a,b)::(pairlist ar br)
  60.     | pairlist _ nil = nil
  61.     | pairlist nil _ = nil 
  62.  
  63.   fun unpairlist l = (map (fn (x,y) => x) l, map (fn (x,y) => y) l)
  64.  
  65.   fun tln (l,0) = l
  66.     | tln (l,n) = tln (tl l,n-1)
  67.  
  68.   fun filter b l =
  69.     let fun f (e::r) = if b e then e::(f r) else (f r)
  70.       | f nil = nil
  71.     in f l
  72.     end
  73.  
  74.   exception Index
  75.   fun index p = 
  76.     let fun f _ nil = raise Index
  77.       | f c (h::t) = if p h then c else f (c+1) t
  78.     in f 0
  79.     end
  80.   val infinity = 1000000000 (* hides one in Basics *)
  81.   
  82.   fun patvars f p =
  83.     let fun patv (VARpat(v as VALvar{access = PATH _,...})) = [f v]
  84.       | patv (VARpat(VALvar{access = INLINE _,...})) = []  (* ??? *)
  85.       | patv (VARpat _) = impossible "non-PATH in DebugUtil.patvars"
  86.       | patv (RECORDpat{fields,...}) = smash (fn (_,p) => patv p) fields
  87.       | patv (APPpat(_,_,p)) = patv p
  88.       | patv (CONSTRAINTpat (p,_)) = patv p
  89.       | patv (LAYEREDpat(p,q)) = patv p @ patv q
  90.       | patv _ = []
  91.     in patv p
  92.     end
  93.  
  94.   fun vblextract f vbl = smash (fn (VB{pat,...}) => patvars f pat) vbl
  95.   
  96.   exception DebugError
  97.   fun debugPanic t = ErrorMsg.impossible ("DebugError:" ^ t ^ "\n")
  98.   fun assert (true,_) = ()
  99.     | assert (false,s) = debugPanic ("Assertion failure " ^ s)
  100.  
  101.   fun forcegc () = U.CInterface.gc 0
  102.  
  103.   fun makeCont (s:string) = 
  104.       callcc(fn a => (callcc (fn b => throw a b);
  105.               debugPanic ("throwing to empty " ^ s)))
  106.  
  107.   val debugdebug = ref false
  108.   fun dbgprint (s:string) = if !debugdebug then print s else ()
  109.  
  110.   val sizereport = ref (fn (s:string) => ())
  111.  
  112.   val debugStatEnv = ref(Env.empty: Modules.env)
  113.  
  114.   val isFn = BasicTypes.isArrowType 
  115.         (* N.B. This doesn't appear to work quite right! *)
  116. end
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.